perm filename CHSD.F4[2,VDS] blob
sn#136670 filedate 1974-12-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00007 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C *** TEST OF "UPDATE", "ROUND", "FIXN", "SCIN"
C00005 00003 SUBROUTINE OUTPUT (PRINT)
C00014 00004 SUBROUTINE CONTRL (START, PRINT)
C00023 00005 SUBROUTINE MESAGE
C00026 00006 SUBROUTINE FIXN
C00029 00007 SUBROUTINE ROUND (K)
C00032 ENDMK
C⊗;
C *** TEST OF "UPDATE", "ROUND", "FIXN", "SCIN"
C NEEDS ABOVE PLUS: "OUTPUT", "CONTRL", "MESAGE",
C "NUMBER", & "EXPON"
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG, NEXT
COMMON /STACK/ P(6), X(6,17), OP(6), D(17)
* /FLAGS/ EEX, DP, N EXT, FIXFLG, MVO, SUM, UFLAG(11)
* /INPUTS/ CODE, EXPR(50), KEY, OLD, DSP(16)
* /PUTPUT/ SKIP, DISPLY(48)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
DATA X /102*13/, R/357*15/, NEXT/.FALSE./, EXPR/50*15/
1 ERROR=0
OLD=1
KEY=1
FIXFLG=.TRUE.
FIX=2
SCI=5
SKIP=2
TYPE 100
ACCEPT 200, (X(1,I), I=1,17)
IF (X (1,1).GT.15) GO TO 1
CALL OUTPUT (0)
NKEYS=99
DO 5 N=1,NKEYS
CALL CONTRL (1, 2)
IF (NEXT) NEXT=.FALSE.
IF (CODE.EQ.32) GO TO 2
IF (CODE.EQ.33) GO TO 3
IF (CODE.EQ.99) GO TO 1
ERROR=81
GO TO 4
2 CALL FIXN
GO TO 4
3 CALL SCIN
4 IF (ERROR.GT.0) CALL MESAGE
5 CONTINUE
GO TO 1
STOP
100 FORMAT (//' ENTER VALUE OF X(1,I), I=1,17'/)
200 FORMAT (17I)
END
SUBROUTINE OUTPUT (PRINT)
C DATE OF LAST CHANGE - 741118
IMPLICIT INTEGER (A-Z)
DIMENSION CHAR(52), STROKE(50), SIGN(6), ESN(6), REG(17)
* , DISP(32), DISP2(16)
CC LOGICAL EEX, DP, FIXFLG, MVO, SUM
CC REAL*8 NAME(3)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
2 /FLAGS/ EEX, DP, NEXT, FIXFLG, MVO, SUM, UFLAG(11)
3 /INPUTS/ CODE, EXPR(50), KEY, OLD, DSP(16)
4 /PUTPUT/ SKIP, DISPLY(32)
5 /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
DATA CHAR( 1),CHAR( 2),CHAR( 3),CHAR( 4)/' 1',' 2',' 3',' 4'/,
2 CHAR( 5),CHAR( 6),CHAR( 7),CHAR( 8)/' 5',' 6',' 7',' 8'/,
3 CHAR( 9),CHAR(10),CHAR(11),CHAR(12)/' 9',' 0',' .','EE'/,
4 CHAR(13),CHAR(14),CHAR(15),CHAR(16)/' -',' +',' ',' /'/,
5 CHAR(17),CHAR(18),CHAR(19),CHAR(20)/' *',' (','**',' )'/,
6 CHAR(21),CHAR(22),CHAR(23),CHAR(24)/' O',' =',' A','PI'/,
7 CHAR(25),CHAR(26),CHAR(27),CHAR(28)/' R','CL','CX','CO'/,
8 CHAR(29),CHAR(30),CHAR(31),CHAR(32)/' E','XX','->','FX'/,
9 CHAR(33),CHAR(34),CHAR(35),CHAR(36)/'SN','IX','XC',' ;'/,
A CHAR(37),CHAR(38),CHAR(39),CHAR(40)/' ,','LX','LY',' ='/,
B CHAR(41),CHAR(42),CHAR(43),CHAR(44)/' #',' >',' <','MG'/,
C CHAR(45),CHAR(46),CHAR(47),CHAR(48)/'AG','AB','SR','↑2'/,
D CHAR(49),CHAR(50),CHAR(51),CHAR(52)/'SC','FL','XX','XX'/
CC DATA NAME /' A =', 'LAST X =','LAST Y ='/
C VARIOUS VALUES OF "SKIP" GIVE: -1 → CLEAR EXPRESSION
C 0 → LONG OUTPUT
C 1 → SHORT OUTPUT
C 2 → DISPLAY ONLY
C
C (IF "PRINT" < "SKIP", "SKIP2" IS SET TO "PRINT")
C
SKIP2=SKIP
IF (PRINT.LT.SKIP) SKIP2=PRINT
IF (SKIP2.GE.0) GO TO 20
DO 10 I=1,50
10 STROKE(I)=CHAR(15)
RETURN
20 DO 30 I=OLD,KEY
J=EXPR(I)
IF (J.EQ.0) J=10
30 STROKE(I)=CHAR(J)
TYPE 1000, (STROKE(I),I=1,KEY)
OLD=KEY+1
IF (SKIP2.EQ.2) GO TO 50
DO 40 I=1,2
J=X(I,1)
IF (J.EQ.0) J=10
SIGN(I)=CHAR(J)
J=X(I,15)
IF (J.EQ.0) J=10
IF (J.EQ.12) J=21
40 ESN(I)=CHAR(J)
50 DO 60 I=1,32
J=DISPLY(I)
IF (J.EQ.0) J=10
60 DISP(I)=CHAR(J)
DO 70 I=1,16
J=DSP(I)
IF (J.EQ.0) J=10
70 DISP2(I)=CHAR(J)
IF (SKIP2.EQ.2) GO TO 90
IF (SKIP2.EQ.1) GO TO 80
CC TYPE 2000, DP, L, EEX, M, FIXFLG, FIX, MVO, SCI, SUM, ERROR
CC TYPE 3000, P(6),SIGN(6),(X(6,N),N=2,14),ESN(6),X(6,16),
CC 2 X(6,17),OP(6),P(5),SIGN(5),(X(5,N),N=2,14),
CC 3 ESN(5),X(5,16),X(5,17),OP(5),P(4),SIGN(4),
CC 4 (X(4,N),N=2,14),ESN(4),X(4,16),X(4,17),OP(4),
CC 5 P(3),SIGN(3),(X(3,N),N=2,14),ESN(3),X(3,16),
CC 6 X(3,17),OP(3)
80 TYPE 4000, P(2),SIGN(2),(X(2,N),N=2,14),ESN(2),X(2,16),
2 X(2,17),OP(2),P(1),SIGN(1),(X(1,N),N=2,14),
3 ESN(1),X(1,16),X(1,17),OP(1)
90 TYPE 5000, DISP
TYPE 6000, DISP2
IF (SKIP2.EQ.2) RETURN
CC DO 110 I=2,4
CC IF (R(I,2).EQ.15) GO TO 110
CC DO 100 J=1,17
CC K=R(I,J)
CC IF (K.EQ.0) K=10
CC100 REG(J)=CHAR(K)
CC TYPE 7000, NAME(I-1), (REG(N), N=1,17)
CC110 CONTINUE
CC DO 130 I=5,20
CC IF (R(I,2).EQ.15) GO TO 130
CC J=I-5
CC DO 120 K=1,17
CC KK=R(I,K)
CC IF (KK.EQ.0) KK=10
CC120 REG(K)=CHAR(KK)
CC TYPE 8000, J, (REG(N), N=1,17)
CC130 CONTINUE
CC DO 140 I=1,11
CC IF (UFLAG(I).EQ.1) GO TO 150
CC140 CONTINUE
CC RETURN
CC150 TYPE 9000, UFLAG
RETURN
1000 FORMAT (/6X, 'EXPRESSION: ', 21A3, (/18X, 21A3))
C2000 FORMAT (//14X,'FLAGS: DP -',L2,20X,'INDICES: L -',
CC 2 I2/22X,'EEX -',L2,30X,'M -',I2/22X,
CC 3 'FIXFLG-',L2,30X,'FIX -',I2/22X,'MVO -',L2,30X,
CC 4 'SCI -',I2/22X,'SUM -',L2,30X,'ERROR -',I2)
C3000 FORMAT (//14X,'STACK: S(6) -',4X,I2,' / ',A2,I2,' .',12I2,
CC 2 A2,2I2,' /',I3/22X,'S(5) -',4X,I2,' / ',A2,I2,' .',
CC 3 12I2,A2,2I2,' /',I3/22X,'S(4) -',4X,I2,' / ',A2,I2,
CC 4 ' .',12I2,A2,2I2,' /',I3/22X,'S(3) -',4X,I2,' / ',
CC 5 A2,I2,' .',12I2,A2,2I2,' /',I3)
4000 FORMAT (/22X,'S(2) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
2 I3/22X,'S(1) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,
3 ' /',I3/)
5000 FORMAT (2(/14X, 'DISPLAY:', 9X, 16A2/)//)
6000 FORMAT (/14X, 'DISPLAY:', 9X, 16A2///)
C7000 FORMAT (15X, A8, 1X, 2A2, ' .', 15A2)
C8000 FORMAT (14X, 'REG(', I2, ') =', 1X, 2A2, ' .', 15A2)
C9000 FORMAT (/14X, 'USER FLAGS:', 6X, I2, 2(2X, 5I2)/)
END
SUBROUTINE CONTRL (START, PRINT)
C DATE OF LAST CHANGE - 741108
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, MVO, SUM, UFLAG(11)
* /INPUTS/ CODE, EXPR(50), KEY, OLD, DSP(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
IF (NEXT) RETURN
GO TO (1, 2, 3, 5), START
1 CALL UPDATE (1)
GO TO 5
2 CALL UPDATE (2)
GO TO 5
3 DO 4 I=1,16
4 DSP(I)=13
5 CALL OUTPUT (PRINT)
6 TYPE 8
ACCEPT 9, CODE
IF (CODE.NE.100) GO TO 7
CALL OUTPUT (1)
GO TO 6
7 KEY=KEY+1
EXPR(KEY)=CODE
IF (CODE.EQ.10) CODE=0
RETURN
8 FORMAT (' ?'/)
9 FORMAT (I)
END
SUBROUTINE UPDATE (START)
C DATE OF LAST CHANGE - 741214
C PURPOSE: 1 - COPY X(1) TO D USING CURRENT DISPLAY FORMAT
C (W CONTAINS X(1) ROUNDED TO RIGHT NO. OF DIGITS)
C 2A - COPY D TO DSP INSERTING SPACING BLANKS
C 2B - COPY DSP TO DSP RIGHT JUSTIFYING MANTISSA
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, NEXT, FIXFLG, MVO, SUM, UFLAG(11)
* /INPUTS/ CODE, EXPR(50), KEY, OLD, DSP(16)
* /PUTPUT/ SKIP, DISPLY(32)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
IF (START.EQ.2) GO TO 20
C ** START1 - UPDATE DISPLAY CONTENTS
D(1)=X(1,1)
IF (OP(1).GT.60) D(1)=15
IF (.NOT.FIXFLG) GO TO 14
C DISPLAY IN "FIX" FORMAT, IF POSSIBLE
IF (X(1,16).GT.0) GO TO 14
IF (X(1,15).EQ.13) GO TO 4
N=X(1,17)+FIX+1
IF (N.GT.10) GO TO 14
CALL ROUND (N)
K=W(17)+1
DO 1 I=1,K
1 D(I+1)=W(I+1)
D(K+2)=11
IF (FIX.EQ.0) GO TO 3
KMAX=K+FIX
K=K+1
DO 2 I=K,KMAX
2 D(I+2)=W(I+1)
3 K=N+2
GO TO 13
4 D(2)=0
D(3)=11
N=FIX-X(1,17)+1
IF (N.LE.0) GO TO 8
CALL ROUND (N)
K=W(17)+1
DO 5 I=3,K
5 D(I+1)=0
IF (K.NE.1) GO TO 6
D(2)=W(2)
GO TO 12
6 DO 7 I=1,N
7 D(K+I+1)=W(I+1)
GO TO 12
8 IF (FIX.EQ.0) GO TO 10
K=FIX+2
DO 9 I=3,K
9 D(I+1)=0
10 IF (N.NE.0) GO TO 12
N=1
CALL ROUND (N)
IF (N.EQ.1) GO TO 12
IF (FIX.NE.0) GO TO 11
D(2)=1
GO TO 12
11 D(FIX+3)=1
12 K=FIX+3
13 KMAX=15
GO TO 18
C DISPLAY IN "SCI" FORMAT
14 N=SCI
CALL ROUND (N)
D(2)=W(2)
D(3)=11
K=SCI+1
IF (W(15).NE.12) GO TO 15
K=10
W(15)=15
15 DO 16 I=2,K
16 D(I+2)=W(I+1)
D(13)=29
DO 17 I=13,15
17 D(I+1)=W(I+2)
K=K+1
IF (K.GT.11) GO TO 20
KMAX=11
18 DO 19 I=K,KMAX
19 D(I+1)=15
C ** START 2 - FORMAT DISPLAY CONTENTS
20 DO 21 II=1,16
DSP(II)=15
DISPLY(II)=D(II)
21 DISPLY(II+16)=29
C COPY D TO DSP, INSERT SPACING BLANKS
DSP(1)=D(1)
I=1
K=0
J=0
N=0
22 N=N+1
IF (D(N+1).GT.9) GO TO 23
K=K+1
IF (K.NE.3) GO TO 22
K=0
J=J+1
GO TO 22
23 N=1
24 IF (K.EQ.0) GO TO 26
IF (D(N+1).GT.11) GO TO 29
25 IF (I.GT.15) GO TO 31
DSP(I+1)=D(N+1)
I=I+1
N=N+1
K=K-1
GO TO 24
26 IF (J.EQ.0) GO TO 28
IF (I.EQ.1) GO TO 27
DSP(I+1)=15
I=I+1
27 K=3
J=J-1
GO TO 24
28 IF (D(N+1).EQ.29) GO TO 30
K=4
J=10
GO TO 25
29 IF (D(13).NE.29) GO TO 34
30 K=13
IF (I.LT.13) GO TO 32
31 K=1
32 DO 33 II=K,16
33 DSP(II)=D(II)
C
34 DO 35 II=1,16
35 DISPLY(II+16)=DSP(II)
C
C COPY DSP TO DSP, RIGHT JUSTIFYING MANTISSA
IF (DSP(12).NE.15) RETURN
K=0
DO 36 II=1,11
IF (DSP(12-II).NE.15) GO TO 37
36 K=K+1
ERROR=82
RETURN
37 J=11-K
DO 38 II=1,J
N=11-II
I=N-K
IF (I.GE.0) GO TO 38
ERROR=83
RETURN
38 DSP(N+1)=DSP(I+1)
IF (N.EQ.0) RETURN
DO 39 II=1,N
39 DSP(II)=15
RETURN
END
SUBROUTINE MESAGE
C DATE OF LAST CHANGE - 741031
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /FLAGS/ EEX, DP, NEXT, FIXFLG, MVO, SUM, UFLAG(11)
* /INPUTS/ CODE, EXPR(50), KEY, OLD, DSP(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
NEXT=.FALSE.
DO 1 I=1,16
1 DSP(I)=13
DSP(4)=15
DSP(5)=29
DSP(6)=25
DSP(7)=25
DSP(8)=21
DSP(9)=25
DSP(10)=15
DSP(11)=ERROR/10
DSP(12)=ERROR-10*DSP(11)
DSP(13)=15
IF (ERROR.LT.16) GO TO 2
DSP(15)=CODE/10
DSP(16)=CODE-10*DSP(15)
2 CALL CONTRL (4, 2)
IF (CODE.EQ.26) GO TO 3
IF (CODE.EQ.27) GO TO 4
GO TO 2
3 NEXT=.TRUE.
4 ERROR=0
RETURN
END
SUBROUTINE EXPON (A,B,C,N)
C DATE OF LAST CHANGE - 740210
C ADD "N" TO THE EXPONENT "ABC" (I.E. SIGN, DIGIT, DIGIT)
IMPLICIT INTEGER (A-Z)
IF (B.EQ.15) B=0
IF (C.EQ.15) C=0
K=10*B+C
IF (A.EQ.13) K=-K
K=K+N
IF (K.GE.0) GO TO 1
K=-K
A=13
GO TO 2
1 A=15
2 B=K/10
C=K-10*B
RETURN
END
SUBROUTINE FIXN
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, MVO, SUM, UFLAG(11)
* /INPUTS/ CODE, EXPR(50), KEY, OLD, DSP(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
FIXFLG=.TRUE.
CALL NUMBER (&1)
FIX=CODE
1 RETURN
END
SUBROUTINE SCIN
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, MVO, SUM, UFLAG(11)
* /INPUTS/ CODE, EXPR(50), KEY, OLD, DSP(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
FIXFLG=.FALSE.
CALL NUMBER (&1)
SCI=CODE+1
1 RETURN
END
SUBROUTINE NUMBER (*)
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, MVO, SUM, UFLAG(11)
* /INPUTS/ CODE, EXPR(50), KEY, OLD, DSP(16)
CALL CONTRL (1, 2)
IF (CODE.LT.10) RETURN
NEXT=.TRUE.
RETURN 1
END
SUBROUTINE ROUND (K)
C DATE OF LAST CHANGE - 741208
C PURPOSE: ROUND X(1,I) TO K DIGITS & PUT RESULT IN W(I)
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(6), X(6,17), OP(6), D(16)
* /MISC/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
1 DO 2 I=1,17
2 W(I)=X(1,I)
IF (K.NE.15) GO TO 3
W(15)=12
RETURN
3 IF (W(2).GE.15) GO TO 4
IF (OP(1).LT.70) GO TO 5
4 W(2)=0
5 CNT=K+2
IF (W(CNT)-5) 13, 6, 9
6 CNT=14
KMAX=K+3
7 IF (W(CNT).GT.0) GO TO 9
IF (CNT.EQ.KMAX) GO TO 8
CNT=CNT-1
GO TO 7
8 CNT=K+1
IF (2*(W(CNT)/2) .EQ. W(CNT)) GO TO 13
9 CNT=K+1
10 W(CNT)=W(CNT)+1
IF (W(CNT).LT.10) GO TO 13
W(CNT)=W(CNT)-10
CNT=CNT-1
IF (CNT.GT.1) GO TO 10
CNT=K+2
11 W(CNT)=W(CNT-1)
IF (CNT.EQ.3) GO TO 12
CNT=CNT-1
GO TO 11
12 W(2)=1
K=K+1
CALL EXPON (W(15), W(16), W(17), 1)
IF (W(16).LT.10) GO TO 13
K=15
GO TO 1
13 RETURN
END